home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / opengl1a / frmmain.frm (.txt) next >
Visual Basic Form  |  1999-09-23  |  11KB  |  329 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BackColor       =   &H00000000&
  4.    BorderStyle     =   0  'None
  5.    Caption         =   "John's Jumping GL Cube"
  6.    ClientHeight    =   5535
  7.    ClientLeft      =   0
  8.    ClientTop       =   0
  9.    ClientWidth     =   7770
  10.    KeyPreview      =   -1  'True
  11.    LinkTopic       =   "Form1"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    ScaleHeight     =   369
  15.    ScaleMode       =   3  'Pixel
  16.    ScaleWidth      =   518
  17.    ShowInTaskbar   =   0   'False
  18.    StartUpPosition =   3  'Windows Default
  19.    WindowState     =   2  'Maximized
  20.    Begin VB.CommandButton Command1 
  21.       Appearance      =   0  'Flat
  22.       BackColor       =   &H00000000&
  23.       Caption         =   "Exit"
  24.       Height          =   285
  25.       Left            =   45
  26.       MaskColor       =   &H00FF0000&
  27.       TabIndex        =   0
  28.       Top             =   30
  29.       Width           =   1650
  30.    End
  31.    Begin VB.Timer Timer1 
  32.       Interval        =   1
  33.       Left            =   120
  34.       Top             =   360
  35.    End
  36. Attribute VB_Name = "frmMain"
  37. Attribute VB_GlobalNameSpace = False
  38. Attribute VB_Creatable = False
  39. Attribute VB_PredeclaredId = True
  40. Attribute VB_Exposed = False
  41. ' Some of this code was created by some unknown person, i downloaded it from the net somewhere,
  42. ' i do not claim to have written the complete code to this program. But i have made plenty of modifications, which basically
  43. ' makes this code my own, only about 10% is somebody elses, mainly the Init of GL.
  44. ' Any problems with this code, email me at the following address:
  45. ' John@john-obrien.freeserve.co.uk
  46. ' Copyright (C) 1999 John O'Brien (Yeah right, i couldn't copyright this code if i tried,
  47. ' because the code is too generic, everybody uses it)
  48. ' Although i have copyrighted this source code and program, you are free to modify, change, hack,
  49. ' learn from, this code and program (that's the idea, and besides i can't stop you!)
  50. ' Happy coding and i hope this helps you on your journey to become a better OpenGL programmer......
  51. Option Explicit
  52. Private Declare Function GetFocus Lib "user32" () As Long
  53. Private Declare Function ChoosePixelFormat Lib "gdi32" (ByVal hDC As Long, pfd As PIXELFORMATDESCRIPTOR) As Long
  54. Private Declare Function CreatePalette Lib "gdi32" (pPal As LOGPALETTE) As Long
  55. Private Declare Sub DeleteObject Lib "gdi32" (hObject As Long)
  56. Private Declare Sub DescribePixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal PixelFormat As Long, ByVal nBytes As Long, pfd As PIXELFORMATDESCRIPTOR)
  57. Private Declare Function GetDC Lib "gdi32" (ByVal hWnd As Long) As Long
  58. Private Declare Function GetPixelFormat Lib "gdi32" (ByVal hDC As Long) As Long
  59. Private Declare Sub GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal start As Long, ByVal entries As Long, ByVal ptrEntries As Long)
  60. Private Declare Sub RealizePalette Lib "gdi32" (ByVal hPalette As Long)
  61. Private Declare Sub SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bln As Long)
  62. Private Declare Function SetPixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal i As Long, pfd As PIXELFORMATDESCRIPTOR) As Boolean
  63. Private Declare Sub SwapBuffers Lib "gdi32" (ByVal hDC As Long)
  64. Private Declare Function wglCreateContext Lib "OpenGL32" (ByVal hDC As Long) As Long
  65. Private Declare Sub wglDeleteContext Lib "OpenGL32" (ByVal hContext As Long)
  66. Private Declare Sub wglMakeCurrent Lib "OpenGL32" (ByVal l1 As Long, ByVal l2 As Long)
  67. Private Type PALETTEENTRY
  68.     peRed As Byte
  69.     peGreen As Byte
  70.     peBlue As Byte
  71.     peFlags As Byte
  72. End Type
  73. Private Type LOGPALETTE
  74.     palVersion As Integer
  75.     palNumEntries As Integer
  76.     palPalEntry(0 To 255) As PALETTEENTRY
  77. End Type
  78. Private Type PIXELFORMATDESCRIPTOR
  79.     nSize As Integer
  80.     nVersion As Integer
  81.     dwFlags As Long
  82.     iPixelType As Byte
  83.     cColorBits As Byte
  84.     cRedBits As Byte
  85.     cRedShift As Byte
  86.     cGreenBits As Byte
  87.     cGreenShift As Byte
  88.     cBlueBits As Byte
  89.     cBlueShift As Byte
  90.     cAlphaBits As Byte
  91.     cAlphaShift As Byte
  92.     cAccumBits As Byte
  93.     cAccumRedBits As Byte
  94.     cAccumGreenBits As Byte
  95.     cAccumBlueBits As Byte
  96.     cAccumAlpgaBits As Byte
  97.     cDepthBits As Byte
  98.     cStencilBits As Byte
  99.     cAuxBuffers As Byte
  100.     iLayerType As Byte
  101.     bReserved As Byte
  102.     dwLayerMask As Long
  103.     dwVisibleMask As Long
  104.     dwDamageMask As Long
  105. End Type
  106. Const PFD_TYPE_RGBA = 0
  107. Const PFD_TYPE_COLORINDEX = 1
  108. Const PFD_MAIN_PLANE = 0
  109. Const PFD_DOUBLEBUFFER = 1
  110. Const PFD_DRAW_TO_WINDOW = &H4
  111. Const PFD_SUPPORT_OPENGL = &H20
  112. Const PFD_NEED_PALETTE = &H80
  113. Dim hPalette As Long
  114. Dim hGLRC As Long
  115. Dim xAngle As GLfloat
  116. Dim yAngle As GLfloat
  117. Dim zAngle As GLfloat
  118. Dim doubleBuffer As GLboolean
  119. Dim displayListInited As GLboolean
  120.                   
  121. Dim MatSpecular(3) As GLfloat
  122. Dim MatShininess(0) As GLfloat
  123. Dim LightPosition(3) As GLfloat
  124. Dim pPos As Long
  125. Dim lasty As Single
  126. Dim i As Long
  127. Sub MyInit()
  128.     MatSpecular(0) = 1
  129.     MatSpecular(1) = 1
  130.     MatSpecular(2) = 1
  131.     MatSpecular(3) = 1
  132.     MatShininess(0) = 50
  133.     LightPosition(0) = 1
  134.     LightPosition(1) = 1
  135.     LightPosition(2) = 1
  136.     LightPosition(3) = 0
  137.     glMaterialfv GL_FRONT, GL_SPECULAR, MatSpecular(0)
  138.     glMaterialfv GL_FRONT, GL_SHININESS, MatShininess(0)
  139.     glLightfv GL_LIGHT0, GL_POSITION, LightPosition(0)
  140.     glEnable GL_LIGHTING
  141.     glEnable GL_LIGHT0
  142.     glDepthFunc GL_LESS
  143.     glEnable GL_DEPTH_TEST
  144. End Sub
  145. Private Sub TEMP()
  146. glColor4i 250, 0, 0, 0
  147.         glVertex4i -1, 1, 1, 1
  148.         glVertex4i 1, -1, 1, -1
  149.         glVertex4i -1, 1, -1, 1
  150.         glVertex4i 1, -1, 1, 1
  151.        
  152.        glColor4i 0, 250, 0, 150
  153.         glVertex4i 1, -1, -1, -1
  154.         glVertex4i -1, 1, -1, 1
  155.         glVertex4i 1, -1, 1, -1
  156.         glVertex4i -1, 1, -1, -1
  157.  glColor4i 0, 250, 0, 150
  158.         glVertex4i -1, 1, 1, -1
  159.         glVertex4i 1, -1, 1, -1
  160.         glVertex4i -1, 1, -1, 1
  161.         glVertex4i 1, -1, -1, 1
  162.  glColor4i 0, 250, 0, 150
  163.         glVertex4i 1, 1, -1, -1
  164.         glVertex4i -1, 1, -1, 1
  165.         glVertex4i 1, 1, 1, -1
  166.         glVertex4i -1, 1, 1, -1
  167. 'Me.Show
  168. End Sub
  169. Sub FatalError(ByVal strMessage As String)
  170. 'Error handler, used when something goes wrong, to exit.
  171.     MsgBox "Fatal Error: " & strMessage, vbCritical + vbApplicationModal + vbOKOnly + vbDefaultButton1, "Fatal Error In " & App.Title
  172.     Unload frmMain
  173.     Set frmMain = Nothing
  174.     End
  175. End Sub
  176. Sub SetupPixelFormat(ByVal hDC As Long)
  177. 'Retrieve/set a Win32 pixel format for OpenGL modes with double-
  178. 'buffering, and direct draw to window with RGBA color mode.
  179. '16bit (65536 colors) depth is preferable.
  180.     Dim pfd As PIXELFORMATDESCRIPTOR
  181.     Dim PixelFormat As Integer
  182.     pfd.nSize = Len(pfd)
  183.     pfd.nVersion = 1
  184.     pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW Or PFD_DOUBLEBUFFER Or PFD_TYPE_RGBA
  185.     pfd.iPixelType = PFD_TYPE_RGBA
  186.     pfd.cColorBits = 16
  187.     pfd.cDepthBits = 16
  188.     pfd.iLayerType = PFD_MAIN_PLANE
  189.     PixelFormat = ChoosePixelFormat(hDC, pfd)
  190.     If PixelFormat = 0 Then FatalError "Could not retrieve pixel format!"
  191.     SetPixelFormat hDC, PixelFormat, pfd
  192. End Sub
  193. Sub SetupPalette(ByVal lhDC As Long)
  194. ' Initialize the Win32 form pallete.
  195.     Dim PixelFormat As Long
  196.     Dim pfd As PIXELFORMATDESCRIPTOR
  197.     Dim pPal As LOGPALETTE
  198.     Dim PaletteSize As Long
  199.     PixelFormat = GetPixelFormat(lhDC)
  200.     DescribePixelFormat lhDC, PixelFormat, Len(pfd), pfd
  201.     If (pfd.dwFlags And PFD_NEED_PALETTE) <> 0 Then
  202.         PaletteSize = 2 ^ pfd.cColorBits
  203.     Else
  204.         Exit Sub
  205.     End If
  206.     pPal.palVersion = &H300
  207.     pPal.palNumEntries = PaletteSize
  208.     Dim redMask As Long
  209.     Dim GreenMask As Long
  210.     Dim BlueMask As Long
  211.     Dim i As Long
  212.     redMask = 2 ^ pfd.cRedBits - 1
  213.     GreenMask = 2 ^ pfd.cGreenBits - 1
  214.     BlueMask = 2 ^ pfd.cBlueBits - 1
  215.     For i = 0 To PaletteSize - 1
  216.         With pPal.palPalEntry(i)
  217.             .peRed = i
  218.             .peGreen = i
  219.             .peBlue = i
  220.             .peFlags = 0
  221.         End With
  222.     Next
  223.     GetSystemPaletteEntries hDC, 0, 256, VarPtr(pPal.palPalEntry(0))
  224.     hPalette = CreatePalette(pPal)
  225.     If hPalette <> 0 Then
  226.         SelectPalette lhDC, hPalette, False
  227.         RealizePalette lhDC
  228.     End If
  229. End Sub
  230. Private Sub Command1_Click()
  231. End Sub
  232. Private Sub F